perm filename TVR.LSP[AID,LSP] blob
sn#688797 filedate 1982-12-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 the matching function
C00005 00003 Macros for Unification
C00035 00004 Choice Macros
C00040 00005 The Unification Matcher
C00059 ENDMK
C⊗;
;;;;;;;;;; the matching function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;; $r, ⊗r - same as RESTRICT
;;; (restrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given the list
;;; that is being considered for that variable as its argument
;;; (irestrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given each element of the list
;;; that is being considered for that variable as its argument
;;; (done incrementally). So %MATCH will apply these predicates as
;;; it scans the input.
;;; $ir,⊗ir - same as irestrict
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;; possible match between p and d (by different *-variable
;;; bindings.
;;; (catch-match <form>) will intercept any backtracks, used in RESTRICT
;;; clauses.
;;*PAGE
;;; Macros for Unification
(DECLARE (SETSYNTAX 35. 2 35.))
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS UMATCH-ALIST))
(declare (special %/#full-predicate %/#OCCURS))
(setq %/#full-predicate ())
(declare (fasload struct fas dsk (mac lsp)))
;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL %/#OCCURS () UMATCH-ALIST ())
(DEFUN %%OCCURS (X L)
(COND ((MEMQ L (CDR (ASSQ X %/#OCCURS))) T)
((EQ X L) ())
(T (%%OCCURS1 X L L))))
(DEFUN %%OCCURS1 (X L TOP)
(COND ((NULL L) ())
((EQ X L) (LET ((ENTRY (ASSQ X %/#OCCURS)))
(COND (ENTRY
(NCONC ENTRY `(,TOP)))
(T (PUSH `(,X . (,TOP))
%/#OCCURS))))
T)
((ATOM L) ())
(T (OR (%%OCCURS1 X (CAR L) TOP)
(%%OCCURS1 X (CDR L) TOP)))))
(MACRODEF MAKE-SPECIAL-FORM (X) (CONS '-SPECIAL-FORM- X))
(MACRODEF SPECIAL-FORM (X)
(LET QQQ ← X DO
(COND ((%%SPECIAL-FORMP QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(MACRODEF %%CHAR1 (ATOM)
;; returns the 1st character of an atom.
(COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))
(MACRODEF REAL-ATOM (%/#X)(AND %/#X (ATOM %/#X)))
(DECLARE (SPECIAL -SEEN-))
(DEFUN %%CHECK (L)
((LAMBDA(-SEEN-)
(%%CHECK1 L)) ()))
(DEFUN %%CHECK1 (L)
(COND ((MEMQ L -SEEN-) L)
((ATOM L) L)
((HUNKP L) (PUSH L -SEEN-) L)
((EQ (CAR L) '-SPECIAL-FORM-)
(CDR L))
((MEMQ (CAR L) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR $CH $CHOOSE))
(CADR L))
(T
(PUSH l -SEEN-)
(CONS (%%CHECK1 (CAR L) )
(%%CHECK1 (CDR L))))))
(MACRODEF PROCESSED-SPECIAL-FORMP (X)
(LET ((Q X))
(COND ((ATOM Q) ())
(T (EQ (CAR Q) '-SPECIAL-FORM-)))))
(MACRODEF ALL-TRUE (FUN %/#L)
(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (RESTRICTP %Q%)
(%%SPECIAL-FORMP %Q%)
(FUNCALL FUN %Q%))
T))))
%/#L)))
(MACRODEF RESTRICTP (%/#X) (AND (NOT (ATOM %/#X))
(MEMQ (CAR %/#X) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))
(MACRODEF EXCHANGE (X Y)
((LAMBDA (Q)
(SETQ X Y)
(SETQ Y Q))
X))
(DEFUN %%SPECIAL-FORMP (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(AND (NOT (EQ X '=))
(MEMQ (%%CHAR1 X) '(? * =)))))
(T (OR (EQ (CAR X) '-SPECIAL-FORM-)
(RESTRICTP X)))) )
(MACRODEF CLAUSE-?-RESTRICTIONS (P D CP CD ALIST)
(COND
((EQ (CADAR P) '?)
;;; normal case of ($r ? ...)
(COND ((%%SPECIAL-FORMP (CAR D))
(SETQ P (CONS (CONS '-SPECIAL-FORM- (CAR P)) (CDR P)))
(EXCHANGE P D)(EXCHANGE CP CD))
(T
(SETQ P (CDR P) D (CDR D))))
(GO UMATCH))
((EQ (%%CHAR1 (CADAR P)) '?)
;;; case of ($r ?foo ...)
((LAMBDA (%T%)
(COND (%T% (SETQ P (CONS (SPECIAL-FORM (CDR %T%)) (CDR P)))
(GO UMATCH))
(T
(LET ((SPECP ())(RESTRP ()))
(COND (
(*CATCH '%/#DECISION-POINT
(COND
((%%OCCURS (CADAR P) (COND ((RESTRICTP (CAR D))
(CADAR D))
(T (CAR D))))
())
((%%SPECIAL-FORMP (CAR D))
(LET ((G (GENSYM))
(ALIST ALIST))
(COND ((RESTRICTP (CAR D))
(COND ((EQ (%%CHAR1 (CADAR D))
'?)
(SETQ SPECP T RESTRP T)
(PUSH (CONS (CADAR D) G) ALIST))))
((EQ (%%CHAR1 (CAR D)) '?)
(SETQ SPECP T)
(PUSH (CONS (CAR D) G) ALIST)))
(COND ((PROCESSED-SPECIAL-FORMP (CAR D))
(%%UMATCH (CDR D) (CDR P) CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND))
(T (%%UMATCH D P CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND)))))
(T (%%UMATCH (CDR P)(CDR D) CP CD
(CONS (CONS (CADAR P)
(CAR D))
ALIST) NOBIND)))
)
(CASEQ NOBIND
(PAIR (PUSH `(,(CADAR P) . ,(%%CHECK (CAR D)))
UMATCH-ALIST)
(COND (SPECP
(COND (RESTRP
(PUSH `(,(CADAR D) . ,(%%CHECK (CADAR P)))
UMATCH-ALIST))
(T (PUSH `(,(CAR D) . ,(%%CHECK (CADAR P)))
UMATCH-ALIST))))))
(() (SET (CADAR P) (%%CHECK (CAR D)))
(COND (SPECP
(COND (RESTRP
(SET (CADAR D) (%%CHECK (CADAR P))))
(T (SET (CAR D) (%%CHECK (CADAR P))))))))
(T ()))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT ())))))))
(ASSQ (CADAR P) ALIST)))))
(MACRODEF CLAUSE-*-RESTRICTIONS (P D CP CD ALIST)
(COND ((EQ (CADAR P) '*)
((LAMBDA (L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ D (DO ((L L (CDR L))
(D D (CDR D)))
((NULL L) D)))
(COND ((NULL D)
(SETQ P (CDR P))
(GO UMATCH))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (CAR D))))
(SP (%%SPECIAL-FORMP (CAR D)))
(OD D OD)
(OP P OP)
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q L)
T))))
(CDDAR P)))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(%%SPECIAL-FORMP (CAR OD)))
(%%UMATCH
OD OP CD CP ALIST NOBIND))
(T
(%%UMATCH (CDR P) D CP CD
ALIST NOBIND)))
)
(AND SP
(*CATCH '%/#DECISION-POINT
(%%UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))
(AND %/#RETAIN
(SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
NIL))
((EQ (%%CHAR1 (CADAR P)) '*)
((LAMBDA (%T%)
(COND (%T% (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (CDR %T%))
T))))
(CDDAR P)))
(SETQ P (APPEND
(SPECIAL-FORM (CDR %T%)) (CDR P)))
(GO UMATCH))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T ((LAMBDA(L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (CAR P)))
(SETQ D (DO ((L L (CDR L))
(D D (CDR D)))
((NULL L) D)))
(COND ((NULL D)
(SETQ P (CDR P))
(GO UMATCH))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (CAR D))))
(SP (%%SPECIAL-FORMP (CAR D)))
(OP P OP)
(OD D OD)
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND((FUNCALL Q L)
T))))
(CDDAR P)))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(%%SPECIAL-FORMP (CAR OD)))
(%%UMATCH OD OP CD CP
(CONS
(CONS (CADAR P)
(CONS
(CONS
'-SPECIAL-FORM-
(CAR OD))
(CDR L)))
ALIST) NOBIND))
(T (%%UMATCH
(CDR P) D CP CD
(CONS
(CONS (CADAR P)
L)
ALIST) NOBIND)) )
)
(AND SP
(*CATCH '%/#DECISION-POINT
(%%UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))
(CASEQ NOBIND
(PAIR (PUSH `(,(CADAR P) . ,(%%CHECK L))
UMATCH-ALIST))
(() (SET (CADAR P) (%%CHECK L)))
(T ()))
(*THROW '%/#DECISION-POINT T )))))))
NIL))))
(ASSQ (CADAR P) ALIST)))))
(MACRODEF CLAUSE-*-IRESTRICTIONS (P D CP CD ALIST)
(COND ((EQ (CADAR P) '*)
((LAMBDA (L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ D (DO ((L L (CDR L))
(D D (CDR D)))
((NULL L) D)))
(COND ((NULL D)
(SETQ P (CDR P))
(GO UMATCH))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (CAR D))))
(F (CAR D)(CAR D))
(SP (%%SPECIAL-FORMP (CAR D)))
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (NULL L)
(RESTRICTP F)
(%%SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(CDDAR P)))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(%%SPECIAL-FORMP (CAR D)))
(%%UMATCH D (CDR P) CD CP ALIST NOBIND))
(T (%%UMATCH (CDR P) D CP CD
ALIST NOBIND)))
)
(AND SP
(*CATCH '%/#DECISION-POINT
(%%UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
NIL))
((EQ (%%CHAR1 (CADAR P)) '*)
((LAMBDA (%T%)
(COND
(%T%
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (RESTRICTP %T%)
(ALL-TRUE Q %T%))
T))))
(CDDAR P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%UMATCH
(CAR P)(CAR D) () () ALIST NOBIND)
)
(SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P)))
(GO UMATCH))
(T (*THROW '%/#DECISION-POINT ()
))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T ((LAMBDA(L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (CAR P)))
(SETQ D (DO ((L L (CDR L))
(D D (CDR D)))
((NULL L) D)))
(COND ((NULL D)
(SETQ P (CDR P))
(GO UMATCH))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (CAR D))))
(F (CAR D)(CAR D))
(OD D OD)
(SP (%%SPECIAL-FORMP (CAR D)))
(OP P OP)
(D D (CDR D))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (NULL L)
(RESTRICTP F)
(%%SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(CDDAR P)))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(%%SPECIAL-FORMP (CAR OD)))
(%%UMATCH OD OP CD CP
(CONS
(CONS (CADAR P)
(CONS (CONS
'-SPECIAL-FORM-
(CAR OD)) (CDR L)))
ALIST) NOBIND))
(T
(%%UMATCH (CDR P) D CP CD
(CONS
(CONS (CADAR P) L)
ALIST) NOBIND)))
)
(AND SP
(*CATCH '%/#DECISION-POINT
(%%UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))
(CASEQ NOBIND
(PAIR (PUSH `(,(CADAR P) . ,(%%CHECK L))
UMATCH-ALIST))
(() (SET (CADAR P) (%%CHECK L)))
(T ()))
(*THROW '%/#DECISION-POINT T )))))))
NIL))))
(ASSQ (CADAR P) ALIST)) )))
(MACRODEF CLAUSE-?-VARIABLE (P D CP CD ALIST)
((LAMBDA (%T%)
(COND (%T% (SETQ P (CONS (SPECIAL-FORM (CDR %T%)) (CDR P)))
(GO UMATCH))
(T
(LET ((SPECP ())
(RESTRP ()))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((%%OCCURS (CAR P) (COND ((RESTRICTP (CAR D))
(CADAR D))
(T (CAR D))))
())
((%%SPECIAL-FORMP (CAR D))
(LET ((G (GENSYM))
(ALIST ALIST))
(COND ((RESTRICTP (CAR D))
(COND ((EQ (%%CHAR1 (CADAR D))
'?)
(SETQ SPECP T RESTRP T)
(PUSH (CONS (CADAR D) G) ALIST))))
((EQ (%%CHAR1 (CAR D)) '?)
(SETQ SPECP T)
(PUSH (CONS (CAR D) G) ALIST)))
(COND ((PROCESSED-SPECIAL-FORMP (CAR D))
(%%UMATCH (CDR D) (CDR P) CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND))
(T (%%UMATCH D P CD CP
(CONS (CONS (CAR P)
G) ALIST) NOBIND)))))
(T
(%%UMATCH (CDR P)(CDR D) CP CD
(CONS (CONS (CAR P)(CAR D))ALIST) NOBIND)))
)
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR P) . ,(%%CHECK (CAR D)))
UMATCH-ALIST)
(COND (SPECP
(COND (RESTRP
(PUSH `(,(CADAR D) . ,(%%CHECK (CAR P)))
UMATCH-ALIST))
(T (PUSH `(,(CAR D) . ,(%%CHECK (CAR P)))
UMATCH-ALIST))))))
(() (SET (CAR P) (%%CHECK (CAR D)))
(COND (SPECP
(COND (RESTRP
(SET (CADAR D) (%%CHECK (CAR P))))
(T (SET (CAR D) (%%CHECK (CAR P))))))))
(T ()))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))))
(ASSQ (CAR P) ALIST)))
(MACRODEF CLAUSE-* (P D CP CD ALIST)
((LAMBDA (L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ D (DO ((L L (CDR L))
(D D (CDR D)))
((NULL L) D)))
(COND ((NULL D)
(SETQ P (CDR P))
(GO UMATCH))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (CAR D))))
(D D (CDR D))
(SP (%%SPECIAL-FORMP (CAR D)))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(%%SPECIAL-FORMP (CAR D)))
(%%UMATCH D (CDR P) CP CD ALIST NOBIND))
(T (%%UMATCH (CDR P) D CP CD ALIST NOBIND) ))
)
(AND SP
(*CATCH '%/#DECISION-POINT
(%%UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))
NIL))
(MACRODEF CLAUSE-*-VARIABLE (P D CP CD ALIST)
((LAMBDA (%T%)
(COND (%T% (SETQ P (APPEND (SPECIAL-FORM (CDR %T%)) (CDR P)))
(GO UMATCH))
(T ((LAMBDA(L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (CAR P)))
(SETQ D (DO ((L L (CDR L))
(D D (CDR D)))
((NULL L) D)))
(COND ((NULL D)
(SETQ P (CDR P))
(GO UMATCH))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (CAR D))))
(D D (CDR D))
(SP (%%SPECIAL-FORMP (CAR D)))
(E (CONS NIL D) (CDR E)))
((NULL E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(%%UMATCH (CDR P) D CP CD
(CONS (CONS (CAR P) L)
ALIST) NOBIND)
)
(AND SP
(*CATCH '%/#DECISION-POINT
(%%UMATCH L
(NCONS (MAKE-SPECIAL-FORM (CAR P)))
CP CD
(CONS (CONS (CAR P) L) ALIST) NOBIND)))
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR P) . ,(%%CHECK L))
UMATCH-ALIST))
(() (SET (CAR P) (%%CHECK L)))
(T ()))
(*THROW '%/#DECISION-POINT T )))))
NIL))))
(ASSQ (CAR P) ALIST)) )
(MACRODEF CLAUSE-=?-VARIABLE (P D CP CD ALIST)
((LAMBDA (%T%)
(COND ((EQ (CAR %T%) '?)
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL (SETQ P (CONS (CDR VAL) (CDR P))))
(T
(SETQ P
(CONS (SYMEVAL VAR) (CDR P)))))
(GO UMATCH))
(ASSQ VAR %/#ALIST)))
(IMPLODE %T%)))
(T
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL (SETQ P (APPEND (CDR VAL) (CDR P))))
(T
(SETQ P
(APPEND (SYMEVAL VAR) (CDR P)))))
(GO UMATCH))
(ASSQ VAR %/#ALIST)))
(IMPLODE %T%)))))
(CDR (EXPLODE (CAR P)))))
;;; Choice Macros
(DEFMACRO CATCH-MATCH (FORM)
`(*CATCH '%/#DECISION-POINT ,FORM))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ())
(MAPEX T))
(EVAL-WHEN (COMPILE EVAL)
(DEFSTRUCT CHOOSER
PAST-CHOICES ORIGINAL-DATA VARIABLE PREDICATES CHOICE EMPTY
SEARCH-LIST
CONSTANTP))
(DEFMACRO CHOOSEP (X) `(AND (NOT (ATOM ,X))
(MEMQ (CAR ,X) '($CHOOSE $CH))))
(DEFMACRO CHOOSE-VAR (X) `(CADR ,X))
(DEFMACRO EMPTY-CHOICE (X) `(EMPTY ,X))
(DEFMACRO COPY (X) `(MAPCAR (FUNCTION (LAMBDA (X) X)) ,X)))
(DEFUN %%UCHOOSE-FIRST (P D)
(%%UCHOOSER
(MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D
CONSTANTP (AND (ATOM P) (NOT (EQ (%%CHAR1 P) '?)))
SEARCH-LIST D
CHOICE ()
EMPTY ()
VARIABLE (COND ((ATOM P) P)
(T (CADR P)))
PREDICATES (COND ((ATOM P) ())
((RESTRICTP P) (CDDR P))))))
(DEFUN %%UCHOOSE-NEXT (OLD-CHOOSER)
(%%UCHOOSER
(MAKE-CHOOSER
PAST-CHOICES (PAST-CHOICES OLD-CHOOSER)
ORIGINAL-DATA (ORIGINAL-DATA OLD-CHOOSER)
CONSTANTP (CONSTANTP OLD-CHOOSER)
SEARCH-LIST (SEARCH-LIST OLD-CHOOSER)
CHOICE ()
EMPTY ()
VARIABLE (VARIABLE OLD-CHOOSER)
PREDICATES (PREDICATES OLD-CHOOSER))))
(DEFMACRO NEXT-CHOICE (X) `(CHOICE ,X))
(DECLARE (*LEXPR %UMATCH))
(DEFUN %MATCH-MEMQ (P L)
(DO ((L L (CDR L)))
((NULL L) ())
(COND ((%UMATCH P (CAR L)) (RETURN L)))))
(DEFUN %%UCHOOSER (CHOOSER)
(LET ((P (VARIABLE CHOOSER))
(D (COPY (ORIGINAL-DATA CHOOSER)))
(SL (COPY (SEARCH-LIST CHOOSER))))
(LET ((CH ()))
(COND ((CONSTANTP CHOOSER)
(COND ((SETQ SL (%MATCH-MEMQ P SL))
(SETQ CH `(,(CAR SL) . ,(DELQ (CAR SL) D)))
(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
(SETF (EMPTY CHOOSER) T))
(T (SETF (CHOICE CHOOSER) CH)
(SETF (SEARCH-LIST CHOOSER) (CDR SL))
(SETF (PAST-CHOICES CHOOSER)
`(,CH . ,(PAST-CHOICES CHOOSER))))))
(T (SETF (EMPTY CHOOSER) T))))
(T (LET ((CAND (%%USEARCH (PREDICATES CHOOSER) SL)))
(COND (CAND
(SETQ CH `(,(CAR CAND)
. ,(DELQ (CAR CAND)
D)))
(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
(SETF (EMPTY CHOOSER) T))
(T (SETF (CHOICE CHOOSER) CH)
(SETF (SEARCH-LIST CHOOSER) (CDR CAND))
(SETF (PAST-CHOICES CHOOSER)
`(,CH . ,(PAST-CHOICES CHOOSER))))))
(T (SETF (EMPTY CHOOSER) T))))))))
CHOOSER)
(DEFUN %%USEARCH (PREDS L)
(DO ((L L (CDR L)))
((NULL L) ())
(COND ((APPLY 'AND
(MAPCAR (FUNCTION (LAMBDA (F)
(FUNCALL F (CAR L))))
PREDS))
(RETURN L)))))
(MACRODEF CHOOSE-CLAUSE (P D CP CD ALIST)
(LET ((PAT (CHOOSE-VAR (CAR P))))
(DO ((DAT (%%UCHOOSE-FIRST PAT D)
(%%UCHOOSE-NEXT DAT)))
((EMPTY-CHOICE DAT) (*THROW '%/#DECISION-POINT ()))
(COND ((*CATCH '%/#DECISION-POINT
(%%UMATCH
(CONS PAT (CDR P))
(NEXT-CHOICE DAT) CP CD ALIST NOBIND))
(*THROW '%/#DECISION-POINT T))))))
;;; The Unification Matcher
;;; Matches 2 patterns.
(declare (special %statistics %calls)(fixnum %calls))
(setq %statistics () %calls 0)
(defun %calls () %calls)
(defun %statistics (x)(and x (setq %calls 0))(setq %statistics x))
;;; (%UMATCH <pat> <data> <initial alist, optional>)
(DEFUN %UMATCH %/#n
(AND %STATISTICS (SETQ %CALLS (1+ %CALLS)))
((LAMBDA(%/#CONTINUE %/#OCCURS)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(%%UMATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) ()) )) NIL NIL))
;;; (%CONTINUE-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN %CONTINUE-UMATCH %/#n
((LAMBDA(%/#CONTINUE %/#OCCURS)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(%%UMATCH (ARG 1)(ARG 2) NIL NIL
(COND
((< 3 %/#n)
(MAPCAR (FUNCTION
(LAMBDA (%/#Q)
(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4))))
()) ))
T ()))
;;; (%UMATCH-NOBIND <pat> <data> <initial alist, optional>)
(DEFUN %UMATCH-NOBIND %/#n
((LAMBDA(%/#CONTINUE %/#OCCURS)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(%%UMATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) T) )) NIL NIL))
;;; (%UMATCH-PAIR <pat> <data> <initial alist, optional>)
(DEFUN %UMATCH-PAIR %/#n
((LAMBDA(%/#CONTINUE %/#OCCURS)
(SETQ %/#CONTINUE-STACK NIL UMATCH-ALIST ())
(*CATCH '%/#DECISION-POINT
(%%UMATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) 'PAIR) )) NIL NIL))
;;; (%%/#CONTINUE-UMATCH-NOBIND <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN %%/#CONTINUE-UMATCH-NOBIND %/#n
((LAMBDA(%/#CONTINUE %/#OCCURS)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(%%UMATCH (ARG 1)(ARG 2) NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4)))) T) ))
T ()))
;;; (%%/#CONTINUE-UMATCH-PAIR <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN %%/#CONTINUE-UMATCH-PAIR %/#n
((LAMBDA(%/#CONTINUE %/#OCCURS)
(SETQ %/#CONTINUE-STACK (ARG 3) UMATCH-ALIST ())
(*CATCH '%/#DECISION-POINT
(%%UMATCH (ARG 1)(ARG 2) NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4)))) 'PAIR) ))
T ()))
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
(DEFUN %%UMATCH (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(OR
(COND
;;; no more pattern
((AND (NULL %/#P) (NULL %/#CP))
;;; so there had better be no more data, unless there are some * vars etc
(COND ((AND (NULL %/#D)(NULL %/#CD))
;;; if this is a reUMATCH, we back up for next try
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
;;; more data loses in some cases
(T (COND ((OR (ATOM %/#D)
(MEMQ (CAR %/#D) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))
(CHOOSEP %/#D))
;;; if %/#D=?<var> or = nil
(SETQ %/#D (NCONS %/#D) %/#P '(NIL))
(GO UMATCH))
((EQ (CAR %/#D) '*)
;;; %/#D=(* ...) could work if (CDR %/#D) is all *-variables
(SETQ %/#D (CDR %/#D))
(GO UMATCH))
((EQ (%%CHAR1 (CAR %/#D)) '*)
;;; we succeed if (CAR %/#D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
((LAMBDA(%T%)
(COND (%T% (SETQ %/#D (APPEND (SPECIAL-FORM (CDR %T%))
(CDR %/#D)))
(GO UMATCH))
(T (COND ((*CATCH '%/#DECISION-POINT
(%%UMATCH
NIL (CDR %/#D) %/#CP %/#CD
(CONS (CONS (CAR %/#D) NIL)
%/#ALIST) NOBIND) )
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR %/#D) . ())
UMATCH-ALIST))
(() (SET (CAR %/#D) ()))
(T ()))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))))
(ASSQ (CAR %/#D) %/#ALIST)))
(T (*THROW '%/#DECISION-POINT NIL ))))))
((NULL %/#P)
;;; if %/#P is null, but %/#D isn't, something is wrong sometimes
(COND (%/#D
(COND ((OR (ATOM %/#D)
(MEMQ (CAR %/#D) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))
(CHOOSEP %/#D))
;;; if %/#D=?<var> or = nil
(SETQ %/#D (NCONS %/#D) %/#P '(NIL))
(GO UMATCH))
((EQ (CAR %/#D) '*)
;;; %/#D=(* ...) could work if (CDR %/#D) is all *-variables
(SETQ %/#D (CDR %/#D))
(GO UMATCH))
((EQ (%%CHAR1 (CAR %/#D)) '*)
;;; we succeed if (CAR %/#D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
((LAMBDA(%T%)
(COND (%T% (SETQ %/#D (APPEND (SPECIAL-FORM (CDR %T%))
(CDR %/#D)))
(GO UMATCH))
(T (COND ((*CATCH '%/#DECISION-POINT
(%%UMATCH
NIL (CDR %/#D) %/#CP %/#CD
(CONS (CONS (CAR %/#D) NIL)
%/#ALIST) NOBIND) )
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR %/#D) . ())
UMATCH-ALIST))
(() (SET (CAR %/#D) ()))
(T ()))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))) )
(ASSQ (CAR %/#D) %/#ALIST)))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
(GO UMATCH))))
((AND (NULL %/#D)
(NOT (RESTRICTP (CAR %/#P))))
;;; if %/#D is null and %/#P isn't, we can still win
(COND ((OR (ATOM %/#P)
(MEMQ (CAR %/#P) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))
(CHOOSEP %/#D))
;;; if %/#P=?<var> or = nil
(SETQ %/#P (NCONS %/#P) %/#D '(NIL))
(GO UMATCH))
((EQ (CAR %/#P) '*)
;;; %/#P=(* ...) could work if (CDR %/#P) is all *-variables
(SETQ %/#P (CDR %/#P))
(GO UMATCH))
((EQ (%%CHAR1 (CAR %/#P)) '*)
;;; we succeed if (CAR %/#P) = (*<var> ...) and *<var> UMATCHed 0 elements.
((LAMBDA(%T%)
(COND (%T% (SETQ %/#P (APPEND (SPECIAL-FORM (CDR %T%))
(CDR %/#P)))
(GO UMATCH))
(T (COND ((*CATCH '%/#DECISION-POINT
(%%UMATCH (CDR %/#P) NIL %/#CP %/#CD
(CONS (CONS (CAR %/#P) NIL)
%/#ALIST) NOBIND) )
(CASEQ NOBIND
(PAIR (PUSH `(,(CAR %/#P) . ())
UMATCH-ALIST))
(() (SET (CAR %/#P) ()))
(T ()))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))))
(ASSQ (CAR %/#P) %/#ALIST)))
))
((OR (REAL-ATOM %/#P) (REAL-ATOM %/#D)
(RESTRICTP %/#P)(RESTRICTP %/#D))
;;; here we listify things if necessary
(SETQ %/#P (NCONS %/#P) %/#D (NCONS %/#D))
(GO UMATCH))
;;; ? restrictions
((AND (NOT (ATOM (CAR %/#P)))
(MEMQ (CAAR %/#P) '($R RESTRICT ⊗R))
(EQ (%%CHAR1 (CADAR %/#P)) '?)
(NOT (NULL %/#D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (%/#PRED) (COND ((OR (RESTRICTP (CAR %/#D))
(%%SPECIAL-FORMP (CAR %/#D))
(FUNCALL %/#PRED (CAR %/#D)))
T))))
(CDDAR %/#P))))
(COND ((EQ (%%CHAR1 (CADAR %/#P)) '?)
(CLAUSE-?-RESTRICTIONS %/#P %/#D %/#CP %/#CD %/#ALIST))
((AND (NOT (EQ (CADAR %/#P) '=))
(EQ (%%CHAR1 (CADAR %/#P)) '=))
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL
(SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))))
(T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))
%/#ALIST (CONS (CONS VAR (SYMEVAL VAR))
%/#ALIST)))))
(ASSQ VAR %/#ALIST)))
(IMPLODE (CDR (EXPLODE (CADAR %/#P)))))
(GO UMATCH))
(T (*THROW '%/#DECISION-POINT () ))))
((AND (NOT (ATOM (CAR %/#P)))
(MEMQ (CAAR %/#P) '($R RESTRICT ⊗R)))
(CLAUSE-*-RESTRICTIONS %/#P %/#D %/#CP %/#CD %/#ALIST))
((AND (NOT (ATOM (CAR %/#P)))
(MEMQ (CAAR %/#P) '($IR IRESTRICT ⊗IR)))
(CLAUSE-*-IRESTRICTIONS %/#P %/#D %/#CP %/#CD %/#ALIST))
((EQ (CAR %/#P) '*)
;;; (* ...)
(CLAUSE-* %/#P %/#D %/#CP %/#CD %/#ALIST))
((EQ (%%CHAR1 (CAR %/#P)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE %/#P %/#D %/#CP %/#CD %/#ALIST))
((AND (NOT (EQ (CAR %/#P) '=))
(EQ (%%CHAR1 (CAR %/#P)) '=))
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE %/#P %/#D %/#CP %/#CD %/#ALIST))
((AND (NOT (ATOM (CAR %/#D)))
(MEMQ (CAAR %/#D) '($R RESTRICT ⊗R))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (%/#PRED) (COND ((OR (RESTRICTP (CAR %/#P))
(%%SPECIAL-FORMP (CAR %/#P))
(FUNCALL %/#PRED (CAR %/#P)))
T))))
(CDDAR %/#D))))
(COND ((EQ (%%CHAR1 (CADAR %/#D)) '?)
(COND ((NULL %/#P)(*THROW '%/#DECISION-POINT ()))
(T (CLAUSE-?-RESTRICTIONS %/#D %/#P %/#CD %/#CP %/#ALIST))))
((AND (NOT (EQ (CADAR %/#P) '=))
(EQ (%%CHAR1 (CADAR %/#P)) '=))
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL
(SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))))
(T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))
%/#ALIST (CONS (CONS VAR (SYMEVAL VAR))
%/#ALIST)))))
(ASSQ VAR %/#ALIST)))
(IMPLODE (CDR (EXPLODE (CADAR %/#P)))))
(GO UMATCH))
(T (*THROW '%/#DECISION-POINT () ))))
((AND (NOT (ATOM (CAR %/#D)))
(MEMQ (CAAR %/#D) '($R RESTRICT ⊗R)))
(CLAUSE-*-RESTRICTIONS %/#D %/#P %/#CD %/#CP %/#ALIST))
((AND (NOT (ATOM (CAR %/#D)))
(MEMQ (CAAR %/#D) '($IR IRESTRICT ⊗IR)))
(CLAUSE-*-IRESTRICTIONS %/#D %/#P %/#CD %/#CP %/#ALIST))
((EQ (CAR %/#D) '*)
;;; (* ...)
(CLAUSE-* %/#D %/#P %/#CD %/#CP %/#ALIST))
((EQ (%%CHAR1 (CAR %/#D)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST))
((AND (NOT (EQ (CAR %/#D) '=))
(EQ (%%CHAR1 (CAR %/#D)) '=))
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST))
((OR (EQ (CAR %/#P) '?) (EQ (CAR %/#D) '?))
;;; easiest case
(SETQ %/#P (CDR %/#P) %/#D (CDR %/#D))
(GO UMATCH))
((EQ (%%CHAR1 (CAR %/#P)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE %/#P %/#D %/#CP %/#CD %/#ALIST))
((EQ (%%CHAR1 (CAR %/#D)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE %/#D %/#P %/#CD %/#CP %/#ALIST))
((EQ (CAR %/#P) (CAR %/#D))
;;; easiest case
(SETQ %/#P (CDR %/#P) %/#D (CDR %/#D))
(GO UMATCH))
((CHOOSEP (CAR %/#P))
(CHOOSE-CLAUSE %/#P %/#D %/#CP %/#CD %/#ALIST))
((CHOOSEP (CAR %/#D))
(CHOOSE-CLAUSE %/#D %/#P %/#CD %/#CP %/#ALIST))
((AND (NOT (ATOM (CAR %/#P)))
(OR (NULL (CAR %/#D))(NOT (ATOM (CAR %/#D)))))
;;; the big recursion
;;; notice that we want nil to be a list here, not an atom
;;; since ((*) ...) (nil ...) needs a chance
(SETQ
%/#CP (CONS (CDR %/#P) %/#CP)
%/#CD (CONS (CDR %/#D) %/#CD)
%/#P (CAR %/#P) %/#D (CAR %/#D))
(GO UMATCH)))
(*THROW '%/#DECISION-POINT () ))))
;;*page